home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / graphics-interface.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  3.7 KB  |  94 lines  |  [TEXT/CCL2]
  1. ;;; graphics-interface.lisp
  2. ;;; 
  3. ;;; this is where the parser and the graphics package are integrated.
  4.  
  5. ;;; avm-tree-object is a subclass of tree-object that can have avm-objects associated
  6. ;;; with each node
  7.  
  8. (defclass avm-tree-object (tree-object)
  9.   ((avs :reader avs :initform nil :initarg :avs)))
  10.  
  11. (defmethod selectable-p ((tree avm-tree-object))
  12.   (avs tree))
  13.  
  14. (defmethod select ((tree avm-tree-object))
  15.   (call-next-method)
  16.   (let ((avs (avs tree)))
  17.     (when avs
  18.       (drawAvm (avs-to-avm avs)))))
  19.  
  20.  
  21. (defun avs-to-avm (avs)
  22.   (let ((copy-generation (list '*avm-copy*))
  23.         (index-count 0))
  24.     (labels ((doNode (avs-node)
  25.                (let ((node (follow-pointers avs-node)))  
  26.                  (if (constant-p node)
  27.                    (make-instance 'string-object :string node)
  28.                    (if (eq (avnode-generation node) copy-generation)
  29.                      (let ((avm (avnode-newcontents node)))
  30.                        (when (null (index avm))
  31.                          (setf (index avm)
  32.                                (make-instance 'index-object
  33.                                               :string (incf index-count))))
  34.                          (make-instance 'index-object
  35.                                         :string (display-string (index avm))))
  36.                      
  37.                      (let ((contents (avnode-contents node))
  38.                            (new-node (make-instance 'avm-object)))         
  39.                        (setf (avnode-generation node) copy-generation)
  40.                        (setf (avnode-newcontents node) new-node)
  41.                        (set-avm-pairs new-node
  42.                                       (mapcar #'(lambda (avp)
  43.                                                   (make-avm-pair (avpair-att avp) 
  44.                                                                  (doNode (avpair-val avp))))
  45.                                               contents))
  46.                        new-node))))))
  47.       (doNode avs))))
  48.  
  49.  
  50. (defun InstToTreeGraphic (inst)
  51.   "builds a set of click-trees"
  52.   (labels ((label (i)
  53.              (let ((c (if *cat-prefix*
  54.                         (avn-att-val (inst-cat i) *cat-prefix*)
  55.                         (inst-cat i))))
  56.                (if c
  57.                  (avs-to-avm c)
  58.                  (make-instance 'string-object :string "")))))
  59.     (if (inst-p inst)
  60.       (make-instance 'avm-tree-object
  61.                      :root (label inst)
  62.                      :avs (if *val-prefix*
  63.                             (make-att-val (inst-cat inst) *val-prefix*)
  64.                             (inst-cat inst))
  65.                      :subtrees (mapcar #'InstToTreeGraphic 
  66.                                        (inst-daughters inst)))
  67.       (make-instance 'string-object :string inst))))
  68.  
  69.  
  70. (defun DrawAvm (avs &key selectable-p)
  71.   "Draws a tree in its own tree window"
  72.   (if (listp avs)
  73.     (setf avs (list-to-avs avs)))
  74.   (let ((front-window (front-window)))
  75.     (unless (and (typep *avm-window* 'graphic-window)
  76.                  (wptr *avm-window*))
  77.       (setf *avm-window* (make-instance 'graphic-window
  78.                                          :window-title "AV Window"
  79.                                          :view-size #@(200 200)
  80.                                          :view-position #@(200 40))))
  81.     (draw-object *avm-window* avs :selectable-p selectable-p)
  82.     (window-show *avm-window*)
  83.     (window-select *avm-window*)
  84.     (window-select front-window)))
  85.  
  86.  
  87. (defun Display (n)
  88.   (if (<= 1 n (length *results*))
  89.     (let ((e (elt *results* (- n 1))))
  90.       (drawTree (InstToTreeGraphic e) :selectable-p T)
  91.       (drawAvm (avs-to-avm (if *val-prefix*
  92.                              (make-att-val (inst-cat e) *val-prefix*)
  93.                              (inst-cat e)))))
  94.     (format t "Sorry, there are only ~s results~%" (length *results*))))